;;;; Defines the EVPL parser.
;;;; Copyright (C) 2009 David J. Rosenbaum, email: davidjrosenbaum@comcast.net
;;;;
;;;; This program is free software: you can redistribute it and/or modify
;;;; it under the terms of the GNU General Public License as published by
;;;; the Free Software Foundation, under version 3 of the License.
;;;;
;;;; This program is distributed in the hope that it will be useful,
;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;;;; GNU General Public License for more details.
;;;;
;;;; You should have received a copy of the GNU General Public License
;;;; along with this program.  If not, see <http://www.gnu.org/licenses/>.
;;;;
;;;; Copyright (C) 2009 David J. Rosenbaum
;;;; This program comes with ABSOLUTELY NO WARRANTY; for details see COPYING.
;;;; This is free software, and you are welcome to redistribute it
;;;; under certain conditions; for details see COPYING.

(in-package :evpl)

(eval-when (:compile-toplevel :load-toplevel :execute)
  (defun infix-to-prefix (argument operator argument2)
    "Converts a list in infix notation to prefix notation."
    (list operator argument argument2))

  (defun first-argument (&rest arguments)
    "Returns the first argument."
    (car arguments))

  (defun second-argument (&rest arguments)
    "Returns the second argument."
    (cadr arguments))

  (defun cons-first-third (&rest arguments)
    "Returns the cons of the first and third arguments."
    (cons (car arguments) (caddr arguments)))

  (defun discard-odd (&rest arguments)
    "Returns a list containing all arguments with even indexes where the index of the first argument is 1."
    (loop for i from 1 for argument in arguments if (evenp i) collect argument))

  (defun discard-even (&rest arguments)
    "Returns a list containing all arguments with odd indexes where the index of the first argument is 1."
    (loop for i from 1 for argument in arguments if (oddp i) collect argument))

  (defun implement-function-call (name argument2 arguments argument4)
    "Returns a form that calls the function named name with the arguments in arguments."
    (declare (ignore argument2 argument4))
    `(funcall ,name ,@arguments))

  (defun implement-hash-table-reference (name argument2 hash-key argument4)
    "Returns a form that performs an hash-table reference."
    (declare (ignore argument2 argument4))
    `(gethash ,hash-key ,name))

  (defun implement-statements (forms &rest arguments)
    "Returns a progn with the elements of forms which must be a list of forms."
    (declare (ignore arguments))
    `(progn ,@forms))

  (defun implement-assignment (place argument2 expression)
    "Assigns expression to place."
    (declare (ignore argument2))
    `(setf ,place ,expression))

  (defun implement-let (argument argument2 bindings argument4 form &rest arguments)
    "Returns a let* with the list of bindings bindings with a body containing form."
    (declare (ignore argument argument2 argument4 arguments))
    `(let* (,@bindings)
       ,form))

  (defun implement-foreach (argument identifier argument3 list body &optional result)
    "Returns a form for a loop that binds each element of list to identifier and executes body at each iteration. When the
loop finishes, the form result is returned."
    (declare (ignore argument argument3))
    `(dolist (,identifier ,list ,result)
       ,body))

  (defun implement-foreach-with-result (argument result identifier argument4 list body)
    "Returns a form for a loop that binds each element of list to identifier and executes body at each iteration. When the
loop finishes, the form result is returned."
    (implement-foreach argument identifier argument4 list body result))

  (defun implement-while (argument argument2 expression argument4 body &optional result)
    "Returns a form for a loop that executes body while expression is not nil and returns result when it finishes."
    (declare (ignore argument argument2 argument4))
    `(loop finally (return ,result) while ,expression do ,body))

  (defun implement-while-with-result (argument argument2 expression argument4 result argument6 body)
    "Returns a form for a loop that executes body while expression is not nil and returns result when it finishes."
    (declare (ignore argument4))
    (implement-while argument argument2 expression argument6 body result))

  (defun implement-function-definition (argument name argument3 parameters argument5 body)
    "Returns a form that defines the function."
    (declare (ignore argument argument3 argument5))
    `(defparameter ,name (lambda (,@parameters)
			   ,body)))

  (defun implement-variable-definitions (argument bindings)
    "Returns a form that will create a new dynamic variable with the appropriate identifier for each binding in binding if
the variable does not exist; if it does exist then its value is set to the value in the binding."
    (declare (ignore argument))
    `(progn ,@(loop for (identifier value) in bindings collect `(defparameter ,identifier ,value))))

  (defun implement-empty-hash-table (argument argument2)
    "Returns a form that will create an empty hash-table."
    (declare (ignore argument argument2))
    `(make-hash-table :test #'equal))
  
  (defun implement-hash-table (argument bindings argument3)
    "Returns a form that will create a hash-table where the car of each binding maps to the cadr of each binding."
    (declare (ignore argument argument3))
    `(funcall evpl.identifiers::|hash-table| ',(mapcar (lambda (binding) (cons (car binding) (cadr binding))) bindings))))

(yacc:define-parser *parser*
  (:start-symbol statements)
  (:terminals (function variable let foreach in while if else return true false ^ * / % + - is = >= <= > < not and or xor
			|<-| |:=| |,| |;| { } |(| |)| |[| |]| identifier float rational integer string))
  (:precedence ((:right ^) (:left * / %) (:left + -) (:nonassoc is = >= <= > <) (:nonassoc not) (:left and) (:left or)
		(:left xor) (:nonassoc |<-| |:=|) (:left |,|)))
  (statements (statements2 #'implement-statements))
  (statements2 (statement |;| statements2 #'cons-first-third)
	       (statement))
  (statement (expression #'first-argument)
	     (assignment #'first-argument)
	     (return-statement #'first-argument)
	     (function-definition #'first-argument)
	     (variable-definitions #'first-argument))
  (expression conditional-expression
	      arithmetic-expression
	      hash-table)
  (expression-list (expression |,| expression-list #'cons-first-third)
		   (expression))
  
  (identifier-list (identifier |,| identifier-list #'cons-first-third)
		   (identifier))
  (assignment (identifier |:=| expression #'implement-assignment)
	      (hash-table-reference |:=| expression #'implement-assignment))
  (block (|{| statements |}| #'second-argument))
  (let-binding (let |(| bindings |)| block #'implement-let))
  (binding (expression |<-| expression #'discard-even))
  (bindings (binding |,| bindings #'cons-first-third)
	    (binding))
  (function-call (identifier |(| expression-list |)| #'implement-function-call))
  (hash-table-reference (identifier |[| expression |]| #'implement-hash-table-reference))
  (if-expression (if |(| expression |)| block #'discard-even)
  		 (if |(| expression |)| block else block #'discard-even))
  (function-definition (function identifier |(| identifier-list |)| block #'implement-function-definition))
  (variable-definitions (variable bindings #'implement-variable-definitions))
  (foreach-loop (foreach identifier in expression block #'implement-foreach)
		(foreach block identifier in expression block #'implement-foreach-with-result))
  (while-loop (while |(| expression |)| block #'implement-while)
	      (while |(| expression |,| expression |)| block #'implement-while-with-result))
  (return-statement (return expression))
  (conditional-expression (not expression)
			  (expression and expression #'infix-to-prefix)
			  (expression or expression #'infix-to-prefix)
			  (expression xor expression #'infix-to-prefix)
			  (expression is expression #'infix-to-prefix)
			  (expression = expression #'infix-to-prefix)
			  (expression >= expression #'infix-to-prefix)
			  (expression <= expression #'infix-to-prefix)
			  (expression > expression #'infix-to-prefix)
			  (expression < expression #'infix-to-prefix))
  (arithmetic-expression (expression ^ expression #'infix-to-prefix)
			 (expression * expression #'infix-to-prefix)
			 (expression / expression #'infix-to-prefix)
			 (expression % expression #'infix-to-prefix)
			 (expression + expression #'infix-to-prefix)
			 (expression - expression #'infix-to-prefix)
			 term)
  (hash-table (|{| |}| #'implement-empty-hash-table)
	      (|{| bindings |}| #'implement-hash-table))
  (term let-binding
	foreach-loop
	while-loop
	if-expression
	block
	(|(| expression |)| #'second-argument)
	(- term)
	function-call
	hash-table-reference
	identifier
	float
	rational
	integer
	string
	true
	false))

(defun parse (lexer)
  "Parses the stream of tokens and returns the lisp expression that it represents.  lexer is a closure that returns the
symbol for next token in the stream as its primary return value and the value of the token as the secondary return value.
lexer must return nil when the token stream is exhausted."
  (yacc:parse-with-lexer lexer *parser*))
